home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 2: Applications / Linux Cubed Series 2 - Applications.iso / editors / emacs / xemacs / xemacs-1.006 / xemacs-1 / lib / xemacs-19.13 / lisp / hyperbole / hmouse-sh.el < prev    next >
Encoding:
Text File  |  1995-04-17  |  11.0 KB  |  283 lines
  1. ;;!emacs
  2. ;;
  3. ;; FILE:         hmouse-sh.el
  4. ;; SUMMARY:      System-dependent Smart Mouse Key bindings (using shift key).
  5. ;; USAGE:        GNU Emacs Lisp Library
  6. ;; KEYWORDS:     hypermedia, mouse
  7. ;;
  8. ;; AUTHOR:       Bob Weiner
  9. ;; ORG:          Brown U.
  10. ;;
  11. ;; ORIG-DATE:     3-Sep-91 at 21:40:58
  12. ;; LAST-MOD:     14-Apr-95 at 16:06:45 by Bob Weiner
  13. ;;
  14. ;; This file is part of Hyperbole.
  15. ;; Available for use and distribution under the same terms as GNU Emacs.
  16. ;;
  17. ;; Copyright (C) 1991-1995, Free Software Foundation, Inc.
  18. ;; Developed with support from Motorola Inc.
  19. ;;
  20. ;; DESCRIPTION:  
  21. ;;
  22. ;;   See description in "hmouse-key.el".
  23. ;;
  24. ;; DESCRIP-END.
  25.  
  26. ;;; ************************************************************************
  27. ;;; Public functions
  28. ;;; ************************************************************************
  29.  
  30. (defun hmouse-get-bindings ()
  31.   "Returns list of bindings for mouse keys prior to their use as Smart Keys."
  32.   (eval
  33.     (cdr (assoc
  34.        hyperb:window-system
  35.        '(("emacs19" .
  36.           (mapcar (function
  37.                (lambda (key) (cons key (lookup-key global-map key))))
  38.               (if (memq window-system '(ns dps))
  39.               ;; NEXTSTEP offers only 2 shift-mouse buttons which we use
  40.               ;; as the Smart Keys.
  41.               '([S-down-mouse-1] [S-mouse-1] [S-down-mouse-2]
  42.                 [S-mouse-2] [S-double-mouse-1] [S-triple-mouse-1]
  43.                 [S-double-mouse-2] [S-triple-mouse-2]
  44.                 [vertical-line S-down-mouse-1]
  45.                 [vertical-line S-mouse-1]
  46.                 [vertical-line S-down-mouse-2]
  47.                 [vertical-line S-mouse-2]
  48.                 [mode-line S-down-mouse-1] [mode-line S-mouse-1]
  49.                 [mode-line S-down-mouse-2] [mode-line S-mouse-2]
  50.                 )
  51.             ;; X
  52.             '([S-down-mouse-2] [S-mouse-2] [S-down-mouse-3]
  53.               [S-mouse-3] [S-double-mouse-2] [S-triple-mouse-2]
  54.               [S-double-mouse-3] [S-triple-mouse-3]
  55.               [vertical-line S-down-mouse-2]
  56.               [vertical-line S-mouse-2]
  57.               [vertical-line S-down-mouse-3]
  58.               [vertical-line S-mouse-3]
  59.               [mode-line S-down-mouse-2] [mode-line S-mouse-2]
  60.               [mode-line S-down-mouse-3] [mode-line S-mouse-3]
  61.               ))))
  62.          ("lemacs" .
  63.           (nconc
  64.         (mapcar (function
  65.               (lambda (key)
  66.                 (cons key (lookup-key global-map key))))
  67.             '([(shift button2)] [(shift button2up)]
  68.               [(shift button3)] [(shift button3up)]))
  69.         (if (boundp 'mode-line-map)
  70.             (mapcar (function
  71.                   (lambda (key)
  72.                 (cons key (lookup-key mode-line-map key))))
  73.                 '([(shift button3)] [(shift button3up)])))))
  74.          ("xterm" .
  75.           (mapcar (function
  76.             (lambda (key) (cons key (lookup-key mouse-map key))))
  77.               (list x-button-s-middle x-button-s-middle-up
  78.                 x-button-s-right  x-button-s-right-up)))
  79.          ("epoch" .
  80.           (mapcar (function
  81.             (lambda (key) (cons key (aref mouse::global-map key))))
  82.               (list (mouse::index mouse-middle mouse-shift)
  83.                 (mouse::index mouse-middle mouse-shift-up)
  84.                 (mouse::index mouse-right mouse-shift)
  85.                 (mouse::index mouse-right mouse-shift-up)
  86.                 ;; Modeline mouse map
  87.                 (mouse::index mouse-mode-middle mouse-shift)
  88.                 (mouse::index mouse-mode-middle mouse-shift-up)
  89.                 (mouse::index mouse-mode-right mouse-shift)
  90.                 (mouse::index mouse-mode-right mouse-shift-up)
  91.                 )))
  92.          ("next" .
  93.           (mapcar (function
  94.             (lambda (key)
  95.               (cons key (mousemap-get
  96.                       (mouse-list-to-mouse-code key)
  97.                       current-global-mousemap))))
  98.               (apply 'nconc
  99.                  (mapcar (function
  100.                        (lambda (region)
  101.                      (mapcar (function
  102.                            (lambda (key)
  103.                              (cons region key)))
  104.                          '((shift left) (shift up left)
  105.                            (shift right)
  106.                            (shift up right)
  107.                            ))))
  108.                      '(text scrollbar modeline minibuffer)))
  109.               ))
  110.          ;; SunView
  111.          ("sun" .
  112.           (mapcar (function
  113.             (lambda (key)
  114.               (setq key (mouse-list-to-mouse-code key))
  115.               (cons key (mousemap-get
  116.                       key current-global-mousemap))))
  117.               (apply 'nconc
  118.                  (mapcar (function
  119.                        (lambda (region)
  120.                      (mapcar (function
  121.                            (lambda (key)
  122.                              (cons region key)))
  123.                          '((shift middle)
  124.                            (shift up middle)
  125.                            (shift right)
  126.                            (shift up right)
  127.                            ))))
  128.                      '(text scrollbar modeline minibuffer)))
  129.               ))
  130.          ("apollo" .
  131.           (mapcar (function
  132.             (lambda (key-str) (apollo-mouse-key-and-binding
  133.                         key-str)))
  134.               '("M2S" "M2U" "M3S" "M3U")))
  135.          )))))
  136.  
  137. (defun hmouse-setup ()
  138.   "Binds mouse keys for use as Smart Keys."
  139.   (interactive)
  140.   (or hmouse-bindings-flag hmouse-previous-bindings
  141.       (setq hmouse-previous-bindings (hmouse-get-bindings)))
  142.   ;; Ensure Gillespie's Info mouse support is off since
  143.   ;; Hyperbole handles that.
  144.   (setq Info-mouse-support nil)
  145.   ;;
  146.   (cond ;; GNU Emacs 19
  147.         ((equal hyperb:window-system "emacs19")
  148.      (setq hmouse-set-point-command 'mouse-set-point)
  149.      (if (memq window-system '(ns dps))
  150.          ;; NEXTSTEP offers only 2 shift-mouse buttons which we use
  151.          ;; as the Smart Keys.
  152.          (progn
  153.            (global-set-key [S-down-mouse-1]      'action-key-depress-emacs19)
  154.            (global-set-key [S-mouse-1]           'action-mouse-key-emacs19)
  155.            (global-set-key [S-double-mouse-1]    'action-mouse-key-emacs19)
  156.            (global-set-key [S-triple-mouse-1]    'action-mouse-key-emacs19)
  157.            (global-set-key [S-down-mouse-2]      'assist-key-depress-emacs19)
  158.            (global-set-key [S-mouse-2]           'assist-mouse-key-emacs19)
  159.            (global-set-key [S-double-mouse-2]    'assist-mouse-key-emacs19)
  160.            (global-set-key [S-triple-mouse-2]    'assist-mouse-key-emacs19)
  161.            (global-set-key [vertical-line S-down-mouse-1] 'action-key-depress-emacs19)
  162.            (global-set-key [vertical-line S-mouse-1]   'action-mouse-key-emacs19)
  163.            (global-set-key [vertical-line S-down-mouse-2]
  164.                    'assist-key-depress-emacs19)
  165.            (global-set-key [vertical-line S-mouse-2]
  166.                    'assist-mouse-key-emacs19)
  167.            (global-set-key [mode-line S-down-mouse-1] 'action-key-depress-emacs19)
  168.            (global-set-key [mode-line S-mouse-1]      'action-mouse-key-emacs19)
  169.            (global-set-key [mode-line S-down-mouse-2] 'assist-key-depress-emacs19)
  170.            (global-set-key [mode-line S-mouse-2]  'assist-mouse-key-emacs19))
  171.        ;; X
  172.        (global-set-key [S-down-mouse-2]      'action-key-depress-emacs19)
  173.        (global-set-key [S-mouse-2]           'action-mouse-key-emacs19)
  174.        (global-set-key [S-double-mouse-2]    'action-mouse-key-emacs19)
  175.        (global-set-key [S-triple-mouse-2]    'action-mouse-key-emacs19)
  176.        (global-set-key [S-down-mouse-3]      'assist-key-depress-emacs19)
  177.        (global-set-key [S-mouse-3]           'assist-mouse-key-emacs19)
  178.        (global-set-key [S-double-mouse-3]    'assist-mouse-key-emacs19)
  179.        (global-set-key [S-triple-mouse-3]    'assist-mouse-key-emacs19)
  180.        (global-set-key [vertical-line S-down-mouse-2] 'action-key-depress-emacs19)
  181.        (global-set-key [vertical-line S-mouse-2]   'action-mouse-key-emacs19)
  182.        (global-set-key [vertical-line S-down-mouse-3]
  183.                'assist-key-depress-emacs19)
  184.        (global-set-key [vertical-line S-mouse-3]
  185.                'assist-mouse-key-emacs19)
  186.        (global-set-key [mode-line S-down-mouse-2] 'action-key-depress-emacs19)
  187.        (global-set-key [mode-line S-mouse-2]      'action-mouse-key-emacs19)
  188.        (global-set-key [mode-line S-down-mouse-3] 'assist-key-depress-emacs19)
  189.        (global-set-key [mode-line S-mouse-3]  'assist-mouse-key-emacs19)))
  190.     ;;
  191.     ;; XEmacs
  192.     ((equal hyperb:window-system "lemacs")
  193.      (setq hmouse-set-point-command 'hmouse-move-point-xemacs)
  194.      (global-set-key '(shift button2)     'action-key-depress)
  195.      (global-set-key '(shift button2up)   'action-mouse-key)
  196.      (if (fboundp 'infodock-set-mouse-bindings)
  197.          (infodock-set-mouse-bindings)
  198.        (if (boundp 'mode-line-map)
  199.            (progn (define-key mode-line-map '(shift button3)
  200.             'assist-key-depress)
  201.               (define-key mode-line-map '(shift button3up)
  202.             'assist-mouse-key)
  203.               ))
  204.        (global-set-key '(shift button3)     'assist-key-depress)
  205.        (global-set-key '(shift button3up)   'assist-mouse-key)))
  206.     ;;
  207.     ;; X
  208.     ((equal hyperb:window-system "xterm")
  209.      (setq hmouse-set-point-command 'x-mouse-set-point)
  210.      (define-key mouse-map x-button-s-middle 'action-key-depress)
  211.      (define-key mouse-map x-button-s-middle-up 'action-mouse-key)
  212.      (define-key mouse-map x-button-s-right 'assist-key-depress)
  213.      (define-key mouse-map x-button-s-right-up 'assist-mouse-key)
  214.      ;; Use these instead of the above for a true META-BUTTON binding.
  215.      ;; (define-key mouse-map x-button-m-middle 'assist-key-depress)
  216.      ;; (define-key mouse-map x-button-m-middle-up 'assist-mouse-key)
  217.      )
  218.     ;;
  219.     ;; Epoch
  220.     ((equal hyperb:window-system "epoch")
  221.      (setq hmouse-set-point-command 'mouse::set-point)
  222.      (global-set-mouse mouse-middle mouse-shift  'action-key-depress)
  223.      (global-set-mouse mouse-middle mouse-shift-up    'action-mouse-key)
  224.      (global-set-mouse mouse-right  mouse-shift  'assist-key-depress)
  225.      (global-set-mouse mouse-right  mouse-shift-up  'assist-mouse-key)
  226.      ;; Modeline mouse map
  227.      (global-set-mouse mouse-mode-middle mouse-shift  'action-key-depress)
  228.      (global-set-mouse mouse-mode-middle mouse-shift-up 'action-mouse-key)
  229.      (global-set-mouse mouse-mode-right  mouse-shift  'assist-key-depress)
  230.      (global-set-mouse mouse-mode-right  mouse-shift-up
  231.                'assist-mouse-key)
  232.      )
  233.     ;;
  234.     ;; NeXT
  235.     ((equal hyperb:window-system "next")
  236.      (setq hmouse-set-point-command 'hmouse-move-point-eterm)
  237.      ;; Use left button to set point.
  238.      ;; Use shift-left button instead of non-existent middle as Action Key.
  239.      (mapcar
  240.       (function
  241.        (lambda (region)
  242.          (global-set-mouse (cons region '(shift left))    'action-key-depress)
  243.          (global-set-mouse (cons region '(shift up left)) 'action-mouse-key)
  244.          (global-set-mouse (cons region '(shift right))   'assist-key-depress)
  245.          (global-set-mouse (cons region '(shift up right))
  246.                    'assist-mouse-key)
  247.          ;; Use these instead of the above for a true META-BUTTON binding.
  248.          ;; (global-set-mouse (cons region '(meta    right)) 'assist-key-depress)
  249.          ;; (global-set-mouse (cons region '(meta up right)) 'assist-mouse-key)
  250.          ))
  251.       '(text scrollbar modeline minibuffer))
  252.      )
  253.     ;;
  254.     ;; SunView
  255.     ((equal hyperb:window-system "sun")
  256.      (setq hmouse-set-point-command 'hmouse-move-point-eterm)
  257.      (mapcar
  258.       (function
  259.        (lambda (region)
  260.          (global-set-mouse (cons region '(shift middle))  'action-key-depress)
  261.          (global-set-mouse (cons region '(shift up middle))
  262.                    'action-mouse-key)
  263.          (global-set-mouse (cons region '(shift right))  'assist-key-depress)
  264.          (global-set-mouse (cons region '(shift up right))
  265.                    'assist-mouse-key)
  266.          ;; Use these instead of the above for a true META-BUTTON binding.
  267.          ;; (global-set-mouse (cons region '(meta    middle)) 'assist-key-depress)
  268.          ;; (global-set-mouse (cons region '(meta up middle)) 'assist-mouse-key)
  269.          ))
  270.       '(text scrollbar modeline minibuffer))
  271.      )
  272.     ;;
  273.     ;; Apollo DM
  274.     ((equal hyperb:window-system "apollo")
  275.      (setq hmouse-set-point-command 'apollo-mouse-move-point)
  276.      (bind-apollo-mouse-button "M2S" 'action-key-depress)
  277.      (bind-apollo-mouse-button "M2U" 'action-mouse-key)
  278.      (bind-apollo-mouse-button "M3S" 'assist-key-depress)
  279.      (bind-apollo-mouse-button "M3U" 'assist-mouse-key)
  280.      ))
  281.   (setq hmouse-bindings (hmouse-get-bindings)
  282.     hmouse-bindings-flag t))
  283.